(in-package #:lilu-swank)

(defvar *connection-name->swank-connection* (make-hash-table :test 'equal))

(defun find-swank-connection (connection-name &key (verify-p nil))
  (let ((conn (gethash connection-name *connection-name->swank-connection*)))
    (if verify-p
        (if (member conn swank::*connections*)
            conn
            (setf (gethash connection-name *connection-name->swank-connection*) nil))
        conn)))

(defun add-swank-connection (connection-name connection)
  (setf (gethash connection-name *connection-name->swank-connection*)
        connection))

(defmacro wait-new-swank-connection (connection-name &body code)
  (let ((new-connection-hook-ori-var (gensym "new-connection-hook-ori-"))
        (done-lock-var (gensym "done-lock-"))
        (done-var (gensym "done-")))
    `(let ((,new-connection-hook-ori-var swank::*new-connection-hook*)
           (,done-lock-var (bordeaux-threads:make-lock "new-connection"))
           (,done-var (bordeaux-threads:make-condition-variable)))
       (unwind-protect
            (progn
              (setf swank::*new-connection-hook*
                    (append swank::*new-connection-hook*
                            (list
                             #'(lambda (con)
                                 (add-swank-connection ,connection-name con)
                                 (bordeaux-threads:with-lock-held (,done-lock-var)
                                   (bordeaux-threads:condition-notify ,done-var))))))
              (bordeaux-threads:with-lock-held (,done-lock-var)
                ,@code
                (bordeaux-threads:condition-wait ,done-var ,done-lock-var)))
         (setf swank::*new-connection-hook* ,new-connection-hook-ori-var))
       (find-swank-connection ,connection-name :verify-p nil))))

(defun open-slime-connection (connection-name slime-port open-slime-fn)
  (wait-new-swank-connection connection-name
    (handler-case
        (progn
          (setf swank::*global-debugger* nil)
          (swank:create-server :port slime-port :dont-close nil))
      (error (condition)
        (format *debug-io* "fail to create a swank server (port: ~A) -- ~A~%" slime-port condition)))
    (funcall open-slime-fn)))

(defun wait-swank-connection (connection-name)
  (let ((conn (find-swank-connection connection-name))
        (done-lock (bordeaux-threads:make-lock "new-connection"))
        (done (bordeaux-threads:make-condition-variable))
        (connection-hook-ori swank::*connection-closed-hook*))
    (unwind-protect
         (progn
           (setf swank::*connection-closed-hook*
                 (append swank::*connection-closed-hook*
                         (list
                          #'(lambda (con)
                              (add-swank-connection connection-name nil)
                              (bordeaux-threads:with-lock-held (done-lock)
                                (bordeaux-threads:condition-notify done))))))
           (bordeaux-threads:with-lock-held (done-lock)
             (bordeaux-threads:condition-wait done done-lock)))
      (setf swank::*connection-closed-hook* connection-hook-ori))))

(defmacro with-swank-connection ((con connection-name) &body code)
  ` (let ((,con (find-swank-connection ,connection-name)))
      (unless ,con
        (error "Impossible to connect to ~A" ,connection-name))
      (swank::with-connection (,con)
        (let ((swank::*buffer-package* (find-package :common-lisp-user))
		      (swank::*buffer-readtable* *readtable*))
          ,@code))))

(defun call-slime-debugger (connection-name condition me-or-my-encapsulation)
  (let ((conn (find-swank-connection connection-name)))
    (unless conn
      (error "Impossible to call slime debugger"))
    (swank::with-connection (conn)
      (funcall #'swank:swank-debugger-hook
               condition me-or-my-encapsulation))))
